home *** CD-ROM | disk | FTP | other *** search
/ The 640 MEG Shareware Studio 2 / The 640 Meg Shareware Studio CD-ROM Volume II (Data Express)(1993).ISO / pascal / fl.zip / FL.PAS
Pascal/Delphi Source File  |  1986-04-10  |  31KB  |  1,119 lines
  1. {$V-}
  2. program FileLister;
  3.  
  4. type
  5.  
  6.        string12 = string[12];
  7.        string64 = string[64];
  8.        string80 = string[80];
  9.  
  10.        SizeArray = array[1..2] of integer;
  11.  
  12.        Fname = array[1..80] of char;
  13.  
  14.        filename_type = string64;
  15.  
  16.        CommandString = string[127];
  17.  
  18.        RegisterSet = record
  19.                        ax,bx,cx,dx,bp,si,di,ds,es,flags : integer;
  20.                      end;
  21.  
  22.        FileArrayType = record
  23.                          FileName  : string[12];
  24.                          Attribute : byte;
  25.                          Time      : integer;
  26.                          Date      : integer;
  27.                          FileSize  : SizeArray;
  28.                        end;
  29.  
  30.        BinaryTreeType = ^node;
  31.  
  32.        node = record
  33.                 FileName     : string[12];
  34.                 Temp         : string[20];
  35.                 Attribute    : byte;
  36.                 Time         : integer;
  37.                 Date         : integer;
  38.                 FileSize     : SizeArray;
  39.                 LeftSubTree,
  40.                 RightSubTree : BinaryTreeType;
  41.               end;
  42.  
  43.        BinaryDirType = ^node2;
  44.  
  45.        node2 = record
  46.                  DirectoryName : string[80];
  47.                  LeftDirTree,
  48.                  RightDirTree  : BinaryDirType;
  49.                end;
  50.  
  51.        DirectoryEntryType = record
  52.                               filler    : array[1..21] of byte;
  53.                               Attribute : byte;
  54.                               FileTime  : integer;
  55.                               FileDate  : integer;
  56.                               FileSize  : SizeArray;
  57.                               FileName  : Fname;
  58.                             end;
  59.  
  60.  
  61. var
  62.  
  63.        P : text;
  64.  
  65.        todaymonth, todayday, todayyear : string[2];
  66.        printout                        : boolean;
  67.  
  68.        CompleteListing                 : boolean;
  69.        SortByExtension                 : boolean;
  70.        SortByDate                      : boolean;
  71.        SortBySize                      : boolean;
  72.        SortBackwards                   : boolean;
  73.        NeedPause                       : boolean;
  74.        NeedAll                         : boolean;
  75.  
  76.        error                           : integer;
  77.        WhatColor                       : integer;
  78.  
  79.        TreeOfStrings                   : BinaryTreeType;
  80.  
  81.        FileArray                       : array[1..512] of FileArrayType;
  82.  
  83.        Buffer                          : CommandString;
  84.        CL                              : CommandString absolute cseg:$80;
  85.  
  86.        NumberFiles                     : integer;
  87.        DirectorySize                   : real;
  88.        CurrentDrive                    : char;
  89.        CurrentDirectory                : filename_type;
  90.        StartDrive                      : char;
  91.        StartDirectory                  : filename_type;
  92.        CurrentFileSpec                 : string[12];
  93.        CurrentVolumeLabel              : string[12];
  94.  
  95.        ChangeDrive                     : boolean;
  96.        ChangeDirectory                 : boolean;
  97.  
  98.        NeedTwoWide                     : boolean;
  99.        NeedFourWide                    : boolean;
  100.        NeedSixWide                     : boolean;
  101.  
  102.  
  103.  
  104. procedure GetToday;
  105.  type regpack = record
  106.                   ax,bx,cx,dx,bp,si,ds,es,flags : integer;
  107.                 end;
  108.  var i, j       : integer;
  109.      recpack    : regpack;
  110.      mm, dd, yy : integer;
  111.      month, day : string[2];
  112.      year       : string[4];
  113. begin
  114.   with recpack do
  115.    begin
  116.      ax := $2a shl 8;
  117.    end;
  118.  
  119.   MsDos(recpack);
  120.  
  121.   with recpack do
  122.    begin
  123.      str(cx, year);
  124.      str(dx mod 256, day);
  125.      str(dx shr 8, month);
  126.    end;
  127.  
  128.   todaymonth := month;
  129.   while (length(todaymonth) < 2) do todaymonth := concat('0', todaymonth);
  130.  
  131.   todayday := day;
  132.   while (length(todayday) < 2) do todayday := concat('0', todayday);
  133.  
  134.   todayyear := year;
  135.   while (length(todayyear) < 2) do todayyear := concat('0', todayyear);
  136. end;
  137.  
  138.  
  139.  
  140. procedure UpperCase(var temp_str : string80);
  141.  var i : integer;
  142.  begin
  143.    for i := 1 to length(temp_str) do
  144.        temp_str[i] := UpCase(temp_str[i]);
  145.  end;
  146.  
  147.  
  148.  
  149. function StripFileName(FileName : string12) : string12;
  150.  var i : integer;
  151.      s : string12;
  152.  begin
  153.    s := '';
  154.    for i := 1 to length(FileName) do
  155.        if (FileName[i] <> ' ') then
  156.            s := s + FileName[i];
  157.    StripFileName := s;
  158.  end;
  159.  
  160.  
  161.  
  162. function StripFileSize(FileSize : SizeArray) : real;
  163.  var r1, r2 : real;
  164.  begin
  165.    r1 := FileSize[1];
  166.    if (r1 < 0) then r1 := r1 + 65536.0;
  167.  
  168.    r2 := FileSize[2];
  169.    if (r2 < 0) then r2 := r2 + 65536.0;
  170.  
  171.    StripFileSize := r2 * 65536.0 + r1;
  172.  end;
  173.  
  174.  
  175.  
  176. procedure PrintDOSDate(Date : integer;
  177.                    WhichWay : integer);
  178.  var month, day : byte;
  179.      year       : integer;
  180.      mm, dd, yy : string[2];
  181.  begin
  182.    year  := 80 + (Date div 512);
  183.    month := (Date mod 512) div 32;
  184.    day   := Date mod 32;
  185.  
  186.    str(month, mm);    if (month < 10) then mm := '0' + mm;
  187.    str(day, dd);      if (day   < 10) then dd := '0' + dd;
  188.    str(year, yy);
  189.  
  190.    if (WhichWay = 1) then write(mm,'-',dd,'-',yy)
  191.    else write(P,mm,'-',dd,'-',yy);
  192.  end;
  193.  
  194.  
  195.  
  196. procedure PrintDOSTime(Time : integer;
  197.                    WhichWay : integer);
  198.  var hour, min, sec : byte;
  199.      hh,   mm,  ss  : string[2];
  200.      scratch        : integer;
  201.      AM             : boolean;
  202.  begin
  203.    scratch := (Time shr 5);
  204.  
  205.    min  := scratch mod 64;
  206.    hour := scratch div 64;
  207.    sec  := (abs(Time) mod 32) * 2;
  208.  
  209.    str(min, mm);    if (min  < 10) then mm := '0' + mm;
  210.    str(hour, hh);   if (hour < 10) then hh := ' ' + hh;
  211.    str(sec, ss);    if (sec < 10) then ss := '0' + ss;
  212.  
  213.    if (WhichWay = 1) then write(hh,':',mm,':',ss)
  214.    else write(P,hh,':',mm,':',ss);
  215.  end;
  216.  
  217.  
  218.  
  219. function Disk_Space(drive : char) : real;
  220.  type result = record
  221.                  al,ah,bl,bh,cl,ch,dl,dh : byte;
  222.                  bp,si,di,ds,es,flags    : integer;
  223.                end;
  224.  var  registers : result;
  225.       wholereg : RegisterSet absolute registers;
  226.       clusters,
  227.       sectors,
  228.       bytes    : real;
  229.       nothing  : file;
  230.  begin
  231.    with registers do
  232.     begin
  233.       case drive of
  234.            'a','A' : dl := 1;
  235.            'b','B' : dl := 2;
  236.            'c','C' : dl := 3;
  237.            'd','D' : dl := 4;
  238.            'e','E' : dl := 5;
  239.            'f','F' : dl := 6;
  240.            'g','G' : dl := 7;
  241.            'h','H' : dl := 8;
  242.       end;
  243.       ah := $36;
  244.  
  245.       MsDos(registers);
  246.     end;
  247.  
  248.    with wholereg do
  249.     begin
  250.       clusters := bx * 1.0;
  251.       bytes    := cx * 1.0;
  252.       sectors  := ax * 1.0;
  253.  
  254.       if (ax = $FFFF) then Disk_Space := -1
  255.       else Disk_Space := clusters * bytes * sectors;
  256.     end;
  257.  end;
  258.  
  259.  
  260.  
  261. procedure GetSetDrive(Activity : char;
  262.                      var Drive : char);
  263.  var DriveNum  : byte;
  264.      registers : RegisterSet;
  265.  begin
  266.    Activity := UpCase(Activity);
  267.  
  268.    case Activity of
  269.         'G' : registers.ax := $19 shl 8;
  270.         'S' : begin
  271.                 registers.ax := $E shl 8;
  272.                 Drive        := UpCase(Drive);
  273.                 registers.dx := ord(Drive) - 65;
  274.               end;
  275.    end;
  276.  
  277.    MsDos(registers);
  278.  
  279.    if (Activity = 'G') then
  280.     begin
  281.       DriveNum := registers.ax and $00FF;
  282.       Drive    := chr(DriveNum + 65);
  283.     end;
  284.  end;
  285.  
  286.  
  287.  
  288. procedure GetSetDirectory(Activity : char;
  289.                          var Drive : char;
  290.                      var Directory : filename_type;
  291.                          var error : integer);
  292.  var done      : boolean;
  293.      i         : integer;
  294.      temp      : string80;
  295.      registers : RegisterSet;
  296.  begin
  297.    Activity := UpCase(Activity);
  298.  
  299.    with registers do
  300.     begin
  301.       case Activity of
  302.            'G' : begin
  303.                    dx := ord(UpCase(Drive)) - 64;
  304.                    ds := seg(Directory);
  305.                    si := ofs(Directory) + 1;
  306.                    ax := $47 shl 8;
  307.                  end;
  308.            'S' : begin
  309.                    Directory[length(Directory) + 1] := #0;
  310.  
  311.                    ds := seg(Directory);
  312.                    dx := ofs(Directory) + 1;
  313.                    ax := $3B shl 8;
  314.                  end;
  315.       end;
  316.  
  317.       MsDos(registers);
  318.  
  319.       if (flags and 1 = 1) then error := ax and $00FF
  320.       else
  321.        begin
  322.          error := 0;
  323.  
  324.          if (Activity = 'G') then
  325.           begin
  326.             done := FALSE;
  327.             temp := '';
  328.             i    := 1;
  329.  
  330.             while not done do
  331.              begin
  332.                if (Directory[i] <> #0) then
  333.                 begin
  334.                   temp := temp + UpCase(Directory[i]);
  335.                   i    := succ(i);
  336.                 end
  337.                else done := TRUE;
  338.              end;
  339.  
  340.             Directory := '\' + temp;
  341.           end;
  342.        end;
  343.     end;
  344.  end;
  345.  
  346.  
  347.  
  348. procedure InsertTree(var Tree : BinaryTreeType;
  349.                          Name : string12;
  350.                          Attr : byte;
  351.                          Time : integer;
  352.                          Date : integer;
  353.                          Size : SizeArray);
  354.  var NewItem : BinaryTreeType;
  355.      Temp_Name : string12;
  356.  begin
  357.    if SortByExtension then
  358.     begin
  359.       if (pos('.',Name) = 0) then Temp_Name := ''
  360.       else Temp_Name := copy(Name, pos('.', Name) + 1, length(Name) - pos('.', Name));
  361.  
  362.       while (length(Temp_Name) < 3) do
  363.        begin
  364.          if (Attr = 16) then Temp_Name := Temp_Name + chr(1)
  365.          else Temp_Name := Temp_Name + ' ';
  366.        end;
  367.  
  368.       if (pos('.', Name) = 0) then Temp_Name := Temp_Name + Name
  369.       else Temp_Name := Temp_Name + '.' + copy(Name, 1, pos('.', Name) - 1);
  370.     end
  371.    else if SortByDate then
  372.     begin
  373.       str(Date:4, Temp_Name);
  374.       Temp_Name := Temp_Name + Name;
  375.     end
  376.    else if SortBySize then
  377.     begin
  378.       str(StripFileSize(Size):7:0, Temp_Name);
  379.       Temp_Name := Temp_Name + Name;
  380.     end
  381.    else Temp_Name := Name;
  382.  
  383.    if (Tree = nil) then
  384.     begin
  385.       New(NewItem);
  386.  
  387.       NewItem^.FileName     := Name;
  388.       NewItem^.Temp         := Temp_Name;
  389.       NewItem^.Attribute    := Attr;
  390.       NewItem^.Time         := Time;
  391.       NewItem^.Date         := Date;
  392.       NewItem^.FileSize[1]  := Size[1];
  393.       NewItem^.FileSize[2]  := Size[2];
  394.       NewItem^.LeftSubtree  := nil;
  395.       NewItem^.RightSubtree := nil;
  396.  
  397.       Tree := NewItem;
  398.     end
  399.    else if SortBackwards then
  400.     begin
  401.       if (Temp_Name > Tree^.Temp) then
  402.            InsertTree(Tree^.LeftSubTree,  Name, Attr, Time, Date, Size)
  403.       else InsertTree(Tree^.RightSubtree, Name, Attr, Time, Date, Size);
  404.     end
  405.    else
  406.     begin
  407.       if (Temp_Name < Tree^.Temp) then
  408.            InsertTree(Tree^.LeftSubTree,  Name, Attr, Time, Date, Size)
  409.       else InsertTree(Tree^.RightSubtree, Name, Attr, Time, Date, Size);
  410.     end;
  411.  end;
  412.  
  413.  
  414.  
  415. procedure ReadDirectory(pattern : string12);
  416.  const Directory = $10;
  417.        carry     = 1;
  418.  var dta      : DirectoryEntryType;
  419.      param    : RegisterSet;
  420.      s_string : string[70];
  421.      Size     : real;
  422.      dta_save : array[1..2] of integer;
  423.  
  424.  function pack_name(var a1; size : integer) : string80;
  425.   var i : integer;
  426.       b : string80;
  427.       a : array[1..1000] of char absolute a1;
  428.  begin
  429.    i := 1;
  430.    b := '';
  431.  
  432.    while (a[i] <> chr(0)) and (i <= 12) do
  433.     begin
  434.       b := b + a[i];
  435.       i := succ(i);
  436.     end;
  437.  
  438.    pack_name := b;
  439.  end;
  440.  
  441.  begin
  442.    with param, dta do
  443.     begin
  444.       TreeOfStrings := nil;
  445.       NumberFiles   := 0;
  446.       DirectorySize := 0;
  447.  
  448.       pattern := pattern + chr(0);
  449.  
  450.       ax := $2F00;
  451.  
  452.       MsDos(param);
  453.  
  454.       dta_save[1] := es;
  455.       dta_save[2] := bx;
  456.  
  457.       ax := $1A00;
  458.       ds := seg(dta);
  459.       dx := ofs(dta);
  460.  
  461.       MsDos(param);
  462.  
  463.       ds := seg(pattern[1]);
  464.       dx := ofs(pattern[1]);
  465.       ax := $4E00;
  466.       cx := $FF;
  467.  
  468.       MsDos(param);
  469.  
  470.       while ((flags and carry) = 0) do
  471.        begin
  472.          s_string := pack_name(FileName, SizeOf(FileName));
  473.  
  474.          if (s_string <> '.') and
  475.             (s_string <> '..') and
  476.             (s_string <> '') and
  477.             (Attribute <> 8) then
  478.              begin
  479.                if (pos('.', s_string) in [1..9]) then
  480.                 begin
  481.                   while (pos('.', s_string) < 9) do
  482.                          insert(' ', s_string, pos('.',s_string));
  483.                 end;
  484.  
  485.                if (Attribute <> 40) then
  486.                    if NeedAll or (Attribute <> 16) then
  487.                     begin
  488.                       InsertTree(TreeOfStrings, s_string, Attribute,
  489.                                  FileTime, FileDate, FileSize);
  490.  
  491.                       NumberFiles := succ(NumberFiles);
  492.  
  493.                       DirectorySize := DirectorySize + StripFileSize(FileSize);
  494.                     end;
  495.  
  496.              end;
  497.  
  498.          ax := $4F00;
  499.  
  500.          MsDos(param);
  501.        end;
  502.     end;
  503.  end;
  504.  
  505.  
  506.  
  507. procedure MakeDirectory;
  508.  var i, kntr : integer;
  509.      Size    : real;
  510.      r1, r2  : real;
  511.      temp    : string80;
  512.      temp1   : string80;
  513.  
  514.  procedure MakeTreeArray(Tree : BinaryTreeType);
  515.   begin
  516.     if (Tree <> nil) then
  517.      begin
  518.        MakeTreeArray(Tree^.LeftSubTree);
  519.  
  520.        kntr := succ(kntr);
  521.  
  522.        FileArray[kntr].FileName  := Tree^.FileName;
  523.        FileArray[kntr].Attribute := Tree^.Attribute;
  524.        FileArray[kntr].Time      := Tree^.Time;
  525.        FileArray[kntr].Date      := Tree^.Date;
  526.        FileArray[kntr].FileSize  := Tree^.FileSize;
  527.  
  528.        MakeTreeArray(Tree^.RightSubTree);
  529.      end;
  530.   end;
  531.  
  532.  procedure DisposeAll(var Tree : BinaryTreeType);
  533.   begin
  534.     if (Tree <> nil) then
  535.      begin
  536.        DisposeAll(Tree^.LeftSubTree);
  537.        Dispose(Tree);
  538.        DisposeAll(Tree^.RightSubTree);
  539.      end;
  540.   end;
  541.  
  542.  begin
  543.    kntr := 0;
  544.  
  545.    MakeTreeArray(TreeOfStrings);
  546.    DisposeAll(TreeOfStrings);
  547.  end;
  548.  
  549.  
  550.  
  551. procedure DoDirectoryPrint;
  552.  var i, MidPoint  : integer;
  553.      line_num     : integer;
  554.      scr_line_num : integer;
  555.      inchar       : char;
  556.  
  557.  procedure TopOfPage(FirstTime : boolean);
  558.   begin
  559.     if FirstTime then
  560.      begin
  561.        ClrScr;
  562.  
  563.        writeln('Directory of:  ',CurrentDrive,':',CurrentDirectory,
  564.                 '':(54 - length(CurrentDirectory)),
  565.                 todaymonth,'/',todayday,'/',todayyear);
  566.  
  567.        writeln;
  568.  
  569.        writeln('     OPTIONS:  /All /Pause /Write             SORT:  /Size /Date /eXt /Back');
  570.  
  571.        Window(1,6,80,23);
  572.  
  573.        writeln;
  574.  
  575.        if NeedTwoWide then
  576.             writeln('FileSpec.Ext   Bytes     Time     Date   ',
  577.                     'FileSpec.Ext   Bytes     Time     Date')
  578.        else if NeedFourWide then
  579.             writeln('FileSpec.Ext  Bytes FileSpec.Ext  Bytes ',
  580.                     'FileSpec.Ext  Bytes FileSpec.Ext  Bytes')
  581.        else writeln('FileSpec.Ext FileSpec.Ext FileSpec.Ext ',
  582.                     'FileSpec.Ext FileSpec.Ext FileSpec.Ext');
  583.      end;
  584.  
  585.     if printout then
  586.      begin
  587.        writeln(P,'Directory of:  ',CurrentDrive,':',CurrentDirectory,
  588.                   '':(54 - length(CurrentDirectory)),
  589.                   todaymonth,'/',todayday,'/',todayyear);
  590.  
  591.        writeln(P);
  592.  
  593.        writeln(P,'        /All /Complete /Pause /Write    /4 /6    /Size /Date /eXt /Back');
  594.  
  595.        writeln(P);
  596.  
  597.        if NeedTwoWide then
  598.             writeln(P,'FileSpec.Ext   Bytes     Time     Date   ',
  599.                       'FileSpec.Ext   Bytes     Time     Date')
  600.        else if NeedFourWide then
  601.             writeln(P,'FileSpec.Ext  Bytes FileSpec.Ext  Bytes ',
  602.                       'FileSpec.Ext  Bytes FileSpec.Ext  Bytes')
  603.        else writeln(P,'FileSpec.Ext FileSpec.Ext FileSpec.Ext ',
  604.                       'FileSpec.Ext FileSpec.Ext FileSpec.Ext');
  605.      end;
  606.  
  607.     line_num := 0;
  608.   end;
  609.  
  610.  procedure TwoWide;
  611.   begin
  612.     write(FileArray[i].FileName,'':(13-length(FileArray[i].FileName)));
  613.  
  614.     if printout then
  615.        write(P,FileArray[i].FileName,'':(13-length(FileArray[i].FileName)));
  616.  
  617.     if (FileArray[i].Attribute = 16) then
  618.      begin
  619.        write('  <DIR> ');
  620.        if printout then write(P,'  <DIR> ');
  621.      end
  622.     else
  623.      begin
  624.        write(StripFileSize(FileArray[i].FileSize):7:0,' ');
  625.        if printout then
  626.           write(P,StripFileSize(FileArray[i].FileSize):7:0,' ');
  627.      end;
  628.  
  629.     PrintDOSTime(FileArray[i].Time, 1);
  630.     write(' ');
  631.     PrintDOSDate(FileArray[i].Date, 1);
  632.  
  633.     if printout then
  634.      begin
  635.        PrintDOSTime(FileArray[i].Time, 2);
  636.        write(P,' ');
  637.        PrintDOSDate(FileArray[i].Date, 2);
  638.      end;
  639.  
  640.     if ((i + MidPoint) <= NumberFiles) then
  641.      begin
  642.        write('   ');
  643.        write(FileArray[i+MidPoint].FileName,
  644.              '':(13-length(FileArray[i+MidPoint].FileName)));
  645.        if (FileArray[i+MidPoint].Attribute = 16) then
  646.             write('  <DIR> ')
  647.        else write(StripFileSize(FileArray[i+MidPoint].FileSize):7:0,' ');
  648.  
  649.        PrintDOSTime(FileArray[i+MidPoint].Time, 1);
  650.        write(' ');
  651.        PrintDOSDate(FileArray[i].Date, 1);
  652.  
  653.        if printout then
  654.         begin
  655.           write(P,'   ');
  656.           write(P,FileArray[i+MidPoint].FileName,
  657.                   '':(13-length(FileArray[i+MidPoint].FileName)));
  658.           if (FileArray[i+MidPoint].Attribute = 16) then
  659.                write(P,'  <DIR> ')
  660.           else write(P,StripFileSize(FileArray[i+MidPoint].FileSize):7:0,' ');
  661.  
  662.           PrintDOSTime(FileArray[i+MidPoint].Time, 2);
  663.           write(P,' ');
  664.           PrintDOSDate(FileArray[i].Date, 2);
  665.         end;
  666.      end;
  667.  
  668.   end;
  669.  
  670.  procedure FourWide;
  671.   begin
  672.     write(FileArray[i].FileName,'':(12-length(FIleArray[i].FileName)));
  673.  
  674.     if printout then
  675.        write(P,FileArray[i].FileName,'':(12-length(FIleArray[i].FileName)));
  676.  
  677.     if (FileArray[i].Attribute = 16) then
  678.      begin
  679.        write('  <DIR> ');
  680.        if printout then write(P,'  <DIR> ');
  681.      end
  682.     else
  683.      begin
  684.        write(StripFileSize(FileArray[i].FileSize):7:0,' ');
  685.        if printout then
  686.           write(P,StripFileSize(FileArray[i].FileSize):7:0,' ');
  687.      end;
  688.  
  689.     if ((i + MidPoint) <= NumberFiles) then
  690.      begin
  691.        write(FileArray[i+MidPoint].FileName,
  692.              '':(12-length(FileArray[i+MidPoint].FileName)));
  693.        if (FileArray[i+MidPoint].Attribute = 16) then
  694.            write('  <DIR> ')
  695.        else write(StripFileSize(FileArray[i+MidPoint].FileSize):7:0,' ');
  696.  
  697.        if printout then
  698.         begin
  699.           write(P,FileArray[i+MidPoint].FileName,
  700.                   '':(12-length(FileArray[i+MidPoint].FileName)));
  701.           if (FileArray[i+MidPoint].Attribute = 16) then
  702.                write(P,'  <DIR> ')
  703.           else write(P,StripFileSize(FileArray[i+MidPoint].FileSize):7:0,' ');
  704.         end;
  705.      end;
  706.  
  707.     if ((i + (2*MidPoint)) <= NumberFiles) then
  708.      begin
  709.        write(FileArray[i+(2*MidPoint)].FileName,
  710.              '':(12-length(FileArray[i+(2*MidPoint)].FileName)));
  711.        if (FileArray[i+(2*MidPoint)].Attribute = 16) then
  712.            write('  <DIR> ')
  713.        else write(StripFileSize(FileArray[i+(2*MidPoint)].FileSize):7:0,' ');
  714.  
  715.        if printout then
  716.         begin
  717.           write(P,FileArray[i+(2*MidPoint)].FileName,
  718.                   '':(12-length(FileArray[i+(2*MidPoint)].FileName)));
  719.           if (FileArray[i+(2*MidPoint)].Attribute = 16) then
  720.                write(P,'  <DIR> ')
  721.           else write(P,StripFileSize(FileArray[i+(2*MidPoint)].FileSize):7:0,' ');
  722.         end;
  723.      end;
  724.  
  725.     if ((i + (3*MidPoint)) <= NumberFiles) then
  726.      begin
  727.        write(FileArray[i+(3*MidPoint)].FileName,
  728.              '':(12-length(FileArray[i+(3*MidPoint)].FileName)));
  729.        if (FileArray[i+(3*MidPoint)].Attribute = 16) then
  730.            write('  <DIR>')
  731.        else write(StripFileSize(FileArray[i+(3*MidPoint)].FileSize):7:0);
  732.  
  733.        if printout then
  734.         begin
  735.           write(P,FileArray[i+(3*MidPoint)].FileName,
  736.                   '':(12-length(FileArray[i+(3*MidPoint)].FileName)));
  737.           if (FileArray[i+(3*MidPoint)].Attribute = 16) then
  738.                write(P,'  <DIR>')
  739.           else write(P,StripFileSize(FileArray[i+(3*MidPoint)].FileSize):7:0);
  740.         end;
  741.      end;
  742.   end;
  743.  
  744.  procedure SixWide;
  745.   begin
  746.     write(FileArray[i].FileName,'':(12 - length(FileArray[i].FileName)));
  747.  
  748.     if printout then
  749.        write(P,FileArray[i].FileName,'':(12 - length(FileArray[i].FileName)));
  750.  
  751.     if ((i + MidPoint) <= NumberFiles) then
  752.      begin
  753.        write(' ',FileArray[i + MidPoint].FileName,
  754.               '':(12-length(FileArray[(i + (NumberFiles mod 6) + ((NumberFiles div 6) * 1))].FileName)));
  755.  
  756.        if printout then
  757.           write(P,' ',FileArray[i + MidPoint].FileName,
  758.                   '':(12-length(FileArray[i + MidPoint].FileName)));
  759.      end;
  760.  
  761.  
  762.     if ((i + (2*MidPoint)) <= NumberFiles) then
  763.      begin
  764.        write(' ',FileArray[i + (2*MidPoint)].FileName,
  765.               '':(12-length(FileArray[i + (2*MidPoint)].FileName)));
  766.  
  767.        if printout then
  768.           write(P,' ',FileArray[i + (2*MidPoint)].FileName,
  769.                   '':(12-length(FileArray[i + (2*MidPoint)].FileName)));
  770.      end;
  771.  
  772.  
  773.     if ((i + (3*MidPoint)) <= NumberFiles) then
  774.      begin
  775.        write(' ',FileArray[i + (3*MidPoint)].FileName,
  776.               '':(12-length(FileArray[i + (3*MidPoint)].FileName)));
  777.  
  778.        if printout then
  779.           write(P,' ',FileArray[i + (3*MidPoint)].FileName,
  780.                   '':(12-length(FileArray[i + (3*MidPoint)].FileName)));
  781.      end;
  782.  
  783.  
  784.     if ((i + (4*MidPoint)) <= NumberFiles) then
  785.      begin
  786.        write(' ',FileArray[i + (4*MidPoint)].FileName,
  787.               '':(12-length(FileArray[i + (4*MidPoint)].FileName)));
  788.  
  789.        if printout then
  790.           write(P,' ',FileArray[i + (4*MidPoint)].FileName,
  791.                   '':(12-length(FileArray[i + (4*MidPoint)].FileName)));
  792.      end;
  793.  
  794.  
  795.     if ((i + (5*MidPoint)) <= NumberFiles) then
  796.      begin
  797.        write(' ',FileArray[i + (5*MidPoint)].FileName,
  798.               '':(12-length(FileArray[i + (5*MidPoint)].FileName)));
  799.  
  800.        if printout then
  801.           write(P,' ',FileArray[i + (5*MidPoint)].FileName,
  802.                   '':(12-length(FileArray[i + (5*MidPoint)].FileName)));
  803.      end;
  804.  
  805. (*
  806.     if ((i + (NumberFiles mod 6) + ((NumberFiles div 6) * 1)) <= NumberFiles) then
  807.      begin
  808.        write(' ',FileArray[(i + (NumberFiles mod 6) + ((NumberFiles div 6) * 1))].FileName,
  809.               '':(12-length(FileArray[(i + (NumberFiles mod 6) + ((NumberFiles div 6) * 1))].FileName)));
  810.  
  811.        if printout then
  812.           write(P,' ',FileArray[(i + (NumberFiles mod 6) + ((NumberFiles div 6) * 1))].FileName,
  813.                   '':(12-length(FileArray[(i + (NumberFiles mod 6) + ((NumberFiles div 6) * 1))].FileName)));
  814.      end;
  815.  
  816.  
  817.     if ((i + (NumberFiles mod 6) + ((NumberFiles div 6) * 2)) <= NumberFiles) then
  818.      begin
  819.        write(' ',FileArray[(i + (NumberFiles mod 6) + ((NumberFiles div 6) * 2))].FileName,
  820.               '':(12-length(FileArray[(i + (NumberFiles mod 6) + ((NumberFiles div 6) * 2))].FileName)));
  821.  
  822.        if printout then
  823.           write(P,' ',FileArray[(i + (NumberFiles mod 6) + ((NumberFiles div 6) * 2))].FileName,
  824.                   '':(12-length(FileArray[(i + (NumberFiles mod 6) + ((NumberFiles div 6) * 2))].FileName)));
  825.      end;
  826.  
  827.  
  828.     if ((i + (NumberFiles mod 6) + ((NumberFiles div 6) * 3)) <= NumberFiles) then
  829.      begin
  830.        write(' ',FileArray[(i + (NumberFiles mod 6) + ((NumberFiles div 6) * 3))].FileName,
  831.               '':(12-length(FileArray[(i + (NumberFiles mod 6) + ((NumberFiles div 6) * 3))].FileName)));
  832.  
  833.        if printout then
  834.           write(P,' ',FileArray[(i + (NumberFiles mod 6) + ((NumberFiles div 6) * 3))].FileName,
  835.                   '':(12-length(FileArray[(i + (NumberFiles mod 6) + ((NumberFiles div 6) * 3))].FileName)));
  836.      end;
  837.  
  838.  
  839.     if ((i + (NumberFiles mod 6) + ((NumberFiles div 6) * 4)) <= NumberFiles) then
  840.      begin
  841.        write(' ',FileArray[(i + (NumberFiles mod 6) + ((NumberFiles div 6) * 4))].FileName,
  842.               '':(12-length(FileArray[(i + (NumberFiles mod 6) + ((NumberFiles div 6) * 4))].FileName)));
  843.  
  844.        if printout then
  845.           write(P,' ',FileArray[(i + (NumberFiles mod 6) + ((NumberFiles div 6) * 4))].FileName,
  846.                   '':(12-length(FileArray[(i + (NumberFiles mod 6) + ((NumberFiles div 6) * 4))].FileName)));
  847.      end;
  848.  
  849.  
  850.     if ((i + (NumberFiles mod 6) + ((NumberFiles div 6) * 5)) <= NumberFiles) then
  851.      begin
  852.        write(' ',FileArray[(i + (NumberFiles mod 6) + ((NumberFiles div 6) * 5))].FileName,
  853.               '':(12-length(FileArray[(i + (NumberFiles mod 6) + ((NumberFiles div 6) * 5))].FileName)));
  854.  
  855.        if printout then
  856.           write(P,' ',FileArray[(i + (NumberFiles mod 6) + ((NumberFiles div 6) * 5))].FileName,
  857.                   '':(12-length(FileArray[(i + (NumberFiles mod 6) + ((NumberFiles div 6) * 5))].FileName)));
  858.      end;
  859. *)
  860.   end;
  861.  
  862.  
  863.  begin
  864.    if      NeedTwoWide  then MidPoint := NumberFiles div 2
  865.    else if NeedFourWide then MidPoint := NumberFiles div 4
  866.    else                      MidPoint := NumberFiles div 6;
  867.  
  868.    scr_line_num := 0;
  869.  
  870.    if NeedTwoWide and odd(NumberFiles) then
  871.         MidPoint := succ(MidPoint)
  872.    else if NeedFourWide and (NumberFiles mod 4 > 0) then
  873.         MidPoint := succ(MidPoint)
  874.    else if NeedSixWide and (NumberFiles mod 6 > 0) then
  875.         MidPoint := succ(MidPoint);
  876.  
  877.    TopOfPage(TRUE);
  878.  
  879.    for i := 1 to MidPoint do
  880.     begin
  881.  
  882.       if NeedPause then
  883.        begin
  884.          scr_line_num := succ(scr_line_num);
  885.          if (scr_line_num = 18) then
  886.           begin
  887.             write('Press any key to continue ... ');
  888.             read(kbd, inchar);
  889.             writeln;
  890.             scr_line_num := 1;
  891.           end;
  892.        end;
  893.  
  894.       if printout then
  895.        begin
  896.          line_num := succ(line_num);
  897.          if (line_num > 50) then
  898.           begin
  899.             writeln(P,chr(12));
  900.             TopOfPage(FALSE);
  901.           end;
  902.        end;
  903.  
  904.       if      NeedTwoWide  then TwoWide
  905.       else if NeedFourWide then FourWide
  906.       else if NeedSixWide  then SixWide;
  907.  
  908.       writeln;
  909.       if printout then writeln(P);
  910.     end;
  911.  
  912.    writeln;
  913.    if printout then writeln(P);
  914.  
  915.    writeln(DirectorySize:8:0,' Bytes in ',NumberFiles,' File(s);  ',
  916.            Disk_Space(CurrentDrive):0:0,' bytes free...');
  917.  
  918.    if printout then
  919.       writeln(P,DirectorySize:8:0,' Bytes in ',NumberFiles,' File(s);  ',
  920.                 Disk_Space(CurrentDrive):0:0,' bytes free...');
  921.  end;
  922.  
  923.  
  924.  
  925. procedure StripBuffer;
  926.  begin
  927.    UpperCase(Buffer);
  928.  
  929.    if (pos('/', Buffer) <> 0) then
  930.     begin
  931.       if (pos('/A', Buffer) <> 0) then
  932.        begin
  933.          NeedAll := TRUE;
  934.          Delete(Buffer, pos('/A', Buffer), 2);
  935.        end;
  936.  
  937.       if (pos('/4', Buffer) <> 0) then
  938.        begin
  939.          NeedTwoWide := FALSE;
  940.          NeedFourWide := TRUE;
  941.          Delete(Buffer, pos('/4', Buffer), 2);
  942.        end;
  943.  
  944.       if (pos('/6', Buffer) <> 0) then
  945.        begin
  946.          NeedTwoWide := FALSE;
  947.          NeedSixWide := TRUE;
  948.          Delete(Buffer, pos('/6', Buffer), 2);
  949.        end;
  950.  
  951.       if (pos('B', Buffer) <> 0) then
  952.        begin
  953.          SortBackwards := TRUE;
  954.          Delete(Buffer, pos('/B', Buffer), 2);
  955.        end;
  956.  
  957.       if (pos('/C', Buffer) <> 0) then
  958.        begin
  959.          ClrScr;
  960.          CompleteListing := TRUE;
  961.          Delete(Buffer, pos('/C', Buffer), 2);
  962.        end;
  963.  
  964.       if (pos('/W', Buffer) <> 0) then
  965.        begin
  966.          printout := TRUE;
  967.          Delete(Buffer, pos('/W', Buffer), 2);
  968.        end;
  969.  
  970.       if (pos('/P', Buffer) <> 0) then
  971.        begin
  972.          NeedPause := FALSE;
  973.          Delete(Buffer, pos('/P', Buffer), 2);
  974.        end;
  975.  
  976.       if (pos('/D', Buffer) <> 0) then
  977.        begin
  978.          SortByDate := TRUE;
  979.          Delete(Buffer, pos('/D', Buffer), 2);
  980.        end;
  981.  
  982.       if (pos('/X', Buffer) <> 0) then
  983.        begin
  984.          SortByExtension := TRUE;
  985.          Delete(Buffer, pos('/X', Buffer), 2);
  986.        end;
  987.  
  988.       if (pos('/S', Buffer) <> 0) then
  989.        begin
  990.          SortBySize := TRUE;
  991.          Delete(Buffer, pos('/S', Buffer), 2);
  992.        end;
  993.     end;
  994.  
  995.    if (pos(':', Buffer) <> 0) then
  996.     begin
  997.       ChangeDrive := TRUE;
  998.  
  999.       CurrentDrive := copy(Buffer, pos(':', Buffer) - 1, 1);
  1000.       GetSetDrive('S', CurrentDrive);
  1001.  
  1002.       Delete(Buffer, pos(':', Buffer) - 1, 2);
  1003.  
  1004.       GetSetDirectory('G', CurrentDrive, CurrentDirectory, error);
  1005.     end;
  1006.  
  1007.    if (pos('\', Buffer) <> 0) then
  1008.     begin
  1009.       ChangeDirectory := TRUE;
  1010.  
  1011.       while (pos(' ', Buffer) <> 0) do
  1012.              Delete(Buffer, pos(' ', Buffer), 1);
  1013.  
  1014.       CurrentDirectory := copy(Buffer, 1, pos('\', Buffer));
  1015.       Delete(Buffer, 1, pos('\', Buffer));
  1016.  
  1017.       while (pos('\', Buffer) <> 0) do
  1018.        begin
  1019.          CurrentDirectory := CurrentDirectory +
  1020.                              copy(Buffer, 1, pos('\', Buffer));
  1021.          Delete(Buffer, 1, pos('\', Buffer));
  1022.        end;
  1023.  
  1024.       if (CurrentDirectory[length(CurrentDirectory)] = '\') then
  1025.           Delete(CurrentDirectory, length(CurrentDirectory), 1);
  1026.  
  1027.       GetSetDirectory('S', CurrentDrive, CurrentDirectory, error);
  1028.     end;
  1029.  
  1030.    if (Buffer <> '') then
  1031.     begin
  1032.       while (pos(' ', Buffer) <> 0) do
  1033.              Delete(Buffer, pos(' ', Buffer), 1);
  1034.  
  1035.       if (Buffer <> '') then CurrentFileSpec := Buffer;
  1036.     end;
  1037.  end;
  1038.  
  1039.  
  1040.  
  1041. function GetScrAttribute : byte;
  1042.  type result = record
  1043.                  AL,AH,BL,BH,CL,CH,DL,DH : Byte;
  1044.                  BP,SI,DI,DS,ES,Flags    : Integer;
  1045.                end;
  1046.  var registers : result;
  1047.  begin
  1048.    with registers do
  1049.     begin
  1050.       BH := 0;
  1051.       AH := 8;
  1052.       Intr($10, registers);
  1053.       GetScrAttribute := AH;
  1054.     end;
  1055.  end;
  1056.  
  1057.  
  1058.  
  1059. begin
  1060.   WhatColor := GetScrAttribute;
  1061.  
  1062.   TextBackground(WhatColor div 16);
  1063.   TextColor(WhatColor mod 16);
  1064.  
  1065.   GetToday;
  1066.  
  1067.   CurrentFileSpec := '*.*';
  1068.  
  1069.   SortByDate      := FALSE;
  1070.   SortByExtension := FALSE;
  1071.   SortBySize      := FALSE;
  1072.   SortBackwards   := FALSE;
  1073.   CompleteListing := FALSE;
  1074.   NeedPause       := TRUE;
  1075.   NeedAll         := FALSE;
  1076.  
  1077.   ChangeDrive     := FALSE;
  1078.   ChangeDirectory := FALSE;
  1079.  
  1080.   NeedTwoWide     := TRUE;
  1081.   NeedFourWide    := FALSE;
  1082.   NeedSixWide     := FALSE;
  1083.  
  1084.   GetSetDrive('G', CurrentDrive);
  1085.   GetSetDirectory('G', CurrentDrive, CurrentDirectory, error);
  1086.  
  1087.   StartDrive      := CurrentDrive;
  1088.   StartDirectory  := CurrentDirectory;
  1089.  
  1090.   printout := FALSE;
  1091.  
  1092.   Buffer := CL;
  1093.  
  1094.   if (Buffer <> '') then StripBuffer;
  1095.  
  1096.   if printout then
  1097.    begin
  1098.      Assign(P,'prn');
  1099.      rewrite(P);
  1100.    end;
  1101.  
  1102.   ReadDirectory(CurrentFileSpec);
  1103.   MakeDirectory;
  1104.   DoDirectoryPrint;
  1105.  
  1106.   if printout then
  1107.    begin
  1108.      writeln(P,chr(12));
  1109.      close(P);
  1110.    end;
  1111.  
  1112.   if ChangeDrive or ChangeDirectory then
  1113.    begin
  1114.      GetSetDrive('S', StartDrive);
  1115.      GetSetDirectory('S', StartDrive, StartDirectory, error);
  1116.    end;
  1117.  
  1118. end.
  1119.